perm filename EARLY.F4[XX,LCS]1 blob sn#199910 filedate 1976-02-04 generic text, type T, neo UTF8
00100	C ********** EARLY MUSIC NOTATION PACKAGE ************
00200		SUBROUTINE EARLY 
00300		IMPLICIT INTEGER(A-Q,S-Z)
00400		REAL POS
00500		COMMON /STF/RSTFAC(-3/4),RSTJ2
00600		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
00700		COMMON/PLTR/PLT,RHT,DIS /POSI/STFF(-3/4),JJ2,POS
00800		COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RB,RZ,RJY,
00900		1 QQ,RJW,ZZ,JX,RG,KL,RJAC,K,L,RQ,RXO,J5X,RNO,JJJ,
01000		1 PUNCT,RDIS,RJ
01100		EQUIVALENCE (R4,RJQ(2)),(J5,JQ(3)),(R6,RJQ(4)),(NJR,RJQ(8)),
01200		1 (J6,JQ(4)),(R8,RJQ(6)),(R7,RJQ(5)),(R9,RJQ(7)),(J9,JQ(7))
01300		1,(J4,JQ(2)),(R3,RJQ(1)),(J10,JQ(8)),(R11,RJQ(9)),(J8,JQ(6))
01400		1,(J7,JQ(5)),(RX3,RJQ(20)),(R5,RJQ(3)),(RH,RJQ(19)),(RXX,RJQ(18))
01500		DATA RBIG/1.5/
01600	
01700		IF(JA.EQ.2)R9=R7
01800		KL=IABS(J6)
01900		IF(KL.GT.5)GO TO 10
02000		IF(R9.NE.0)GO TO 2
02100	10	IF(JA.EQ.1)J5=J6
02200		IF(KL.GE.30)GO TO 30
02300	C  JUMP FOR MENSURATION SIGNS.
02400	C  PUT NUM. IN P6 IF P9 NOT USED. 20=MAXIMA, 21=LONGA, 22=BREVIS, ETC.
02500		IF(R8.EQ.0)R8=-2
02600	C  SET 'COLORATION' IN P8 IF NOT SET BY RHYTH.(P9)  -1=BLACK, 0=WHITE HERE.
02700		GO TO 3
02800	2	RA=AMOD(R9,.25)
02900	C  RA=0=WHITE,  ≠0='COLORATION'
03000		IF(RA.NE.0)R9=R9*1.5
03100	C  TO GET THE RIGHT SHAPE
03200		J5=19.5+ALOG(16./R9)/.693147181
03300	C  I.E. /ALOG(2.)  FINDS SEQ. NUM IN DRAW FILE 'EARLY'. 20=MAXIMA, ETC.
03400		R8=-1
03500	C  FILL IT ALWAYS (BLACK NOTE)
03600		IF(RA.EQ.0)R8=-2
03700	C  ALWAYS WHITE
03800	3	IF(JA.EQ.2)GO TO 20
03900		RH=R5
04000		JA=3 
04100		K=J4
04200		RXX=POS-18.*RSTJ2
04300		IF(J5.LT.20)GO TO 6
04400	C GO MAKE 'LIGATURES' P6=11=1 UP, =-11=1 DOWN, 12=2 UP, ETC.
04500		R6=RBIG
04600		NJR='CLEF2'
04700	C  ↑↑↑ EQUIV. TO R10
04800		R7=RBIG
04900		IF(R5)R6=-R6
05000	C  IF P5 IS NEG THEN ITEM MOVES TO LEFT EXACTLY ITS SPACE.
05100	5	J9=0
05200	C  NO ROTATION PLEASE.
05300	CC	IF(R5.LT.20.)GO TO 7
05400	C  TURN OVER THE NOTE
05500	CC	R4=R4-5.8
05600	CC	R7=-R6
05650	7	RSS=RG
05700		CALL CLEFS
05800		IF(J7.GE.0)GO TO 1
05900	C IF P7 IS NEG THERE WILL BE A STEM ON LFT SIDE =ABS(R7), P5 HAS UP-DN.
06000		RG=R4
06100		R5=-J7*RST7
06200		GO TO 14
06300	6	RG=R4
06400	C THIS WILL BE FOR LIGATURE STEMS (P5=10=UP, =20=DOWN)
06500		IF(KL.GT.10)GO TO 11
06600		R6=-R6*10.
06700		GO TO 12
06800	11	R6=KL-10
06900		IF(J6)R6=-R6
07000	12	RA=R3
07100		IF(J8)GO TO 9
07200		R4=R4-.45
07300		J5=50
07400	C  P8<0=BLACK LIG.   ≥0=WHITE LIG.
07500		J10=1
07600		R9=1.7
07700		R8=3.64
07800		R11=R6
07900		R3=R3+13.85*RSTJ2
08000		GO TO 8
08100	9	R4=R4-.9
08200		R5=R4+R6/RSTJ2
08300	CC	R9=200
08400		J7=1
08500		R8=4.6
08600		R6=RX3+R8
08700		J10=14.*RSTJ2
08800	C  MAKES SLOPED DASH, 14XTHICK
08900	8	CALL ITMSUB
09000		IF(RH.EQ.0)GO TO 13
09100		R5=5*RST7
09200	14	RG=RG*RST7+RXX
09300		IF(RH.GE.20)R5=-R5
09400	C NOW STEM IS DOWN. (-R5)
09500		CALL LINX(R3,RG,R3,RG+R5)
09600	13	R4=RG
09700		J5=20
09800		R3=RA
09900	
10000	1	IF(K.LT.502)GO TO 4
10100		IF(K.LT.513)RETURN
10200	C  WILL NOW DO 1 LEDG. LINE ABOVE OR BELOW.
10300	4	R4=RST7
10400		IF(K.GT.502)R4=13.*RST7
10500		R4=R4+RXX
10600		R5=20.
10700		IF(J5.EQ.20)R5=34.
10800		CALL LINX(R3-RST7,R4,R3+R5*RSTJ2,R4)
10900	
11000		RETURN
11100	
11200	20	IF(R9.NE.0)J5=R5+23.
11300		RG=POS
11400	C SAVE IT FOR SEMIMINIM REST HORIZANTAL
11500	C  RESTS ARE SET BY RHYTHM(R9,7) OR IN J5 (20-25)
11600		R5=(J5-20)*2+3
11700		RA=R4
11800		IF(R5.GT.8.)R5=8.
11900		R5=R4+R5
12000	C  RESTS (500+ IN P4) CAN BE MOVED UP OR DOWN
12100		R4=9
12200		IF(J5.GT.23)R4=7.
12300		R4=R4+RA
12400		J10=2
12500		J7=0
12600		R6=RX3
12700	C ALL THIS MAKES VERT. LINE.
12800		CALL ITMSUB
12900		IF(J5.LT.25)RETURN
13000	C NEXT IS FOR SEMIMINIM REST (1/16)
13100		R6=RX3+1.3
13200		R4=8+RA
13300		R5=R4
13400		POS=RG
13500		CALL ITMSUB
13600	 	RETURN
13700	
13800	C  MENSURATION SIGNS. USES P6 AS A NOTE. =30=C; 31=C.; 32=C/; 33=O; 34=O/
13900	30	JA=12
13910		R4=R4+6
13920		CALL CENTX
13930	C  P4=500 PUTS IT AT POS 6.
14000		R5=1
14100		J8=1
14200		IF(J5.GT.32)GO TO 31
14300	C  NEXT ARE C'S
14400		J6=125
14500		J7=45
14600		GO TO 32
14700	31	J6=0
14800		J7=0
14900	32	CALL SLUR
15000		IF(J5.NE.31)GO TO 33
15100	C  NEXT IS C.
15110		J5=0
15200		J6=0
15250		J7=0
15300		R5=.1
15400		GO TO 31
15500	33	IF(J5.LT.32)RETURN
15600		IF(J5.EQ.33)RETURN
15800		R5=R4+1
15810		R4=R4-1
15900		R3=R3-11.*RSTJ2
16000		J7=0
16100		R6=RX3+2*RSTJ2
16200		CALL ITMSUB
16300		END